;;; firemacs-buffer.el --- operations for editing a firemacs buffer

;; Copyright 2007 Lukas Loehrer
;;
;; Author: loehrerl [at] gmx [dot] net
;; Version: $Id: firemacs-buffer.el,v 0.0 2007/01/13 08:22:28 luke Exp $
;; Keywords: 
;; X-URL: not distributed yet

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; 

;; Put this file into your load-path and the following into your ~/.emacs:
;;   (require 'firemacs-buffer)

;;; Code:

(provide 'firemacs-buffer)
(eval-when-compile
  (require 'cl))

;;{{{Variables

(defvar firemacs-buffer-node-table nil
  "Hash table to associate DOM nodes with nodes in the buffer.

This variable is local to the current firemacs buffer.")

(defconst firemacs-form-roles
  '(fm-role-button fm-role-pushbutton fm-role-entry fm-role-password fm-role-checkbox fm-role-radiobutton fm-role-combobox)
  "List of roles of form elements.")

(defconst firemacs-interactive-roles
  (append firemacs-form-roles '(fm-role-link))
  "List of roles of interactive elements.")

;;}}}
;;{{{Face and voice definitions

;; The faces are just markers for the voices, thus we do not try to
;; make them "look" good.
(defface firemacs-link-face nil
   "Face for links.")

(defface firemacs-heading-face nil
   "Face for links.")


(defcustom firemacs-role-font-alist
  '(
	(fm-role-link . firemacs-link-face)
	(fm-role-heading . firemacs-heading-face)
	)
  "Mapping from roles to faces."
  :group 'firemacs)
  

;;}}}
;;{{{Some rendering functions

(defsubst firemacs-insert-hard-newline ()
  "Insert a hard newline into the buffor."
  (let ((start (point)))
	(insert "\n")
	(put-text-property start (point) 'hard t)
	(add-to-text-property start  'rear-nonsticky  'hard)))

;;}}}
;;{{{Queries

(defun firemacs-buffer-node-at (pos)
  "Get lowest node at POS."
  (let ((ref (get-char-property  pos 'fm-ref)))
	(when ref
	  (firemacs-node-for-ref ref))))
		

(defsubst firemacs-node-for-ref (ref)
  "Get node for REF."
  (gethash ref firemacs-buffer-node-table))

(defsubst firemacs-node-get-property (node prop)
  (overlay-get node prop))

(defsubst firemacs-node-set-property (node prop value)
  (overlay-put node prop value))

(defsubst firemacs-ref-for-node (node)
  (firemacs-node-get-property node 'fm-ref))

(defsubst firemacs-parent-node (node)
  (firemacs-node-get-property node 'fm-parent))

(defsubst firemacs-child-nodes (node)
  (firemacs-node-get-property node 'fm-children))

(defsubst firemacs--atomic-node-p (node)
  "Return t if NODE has no child nodes."
  (not (firemacs-child-nodes node)))

(defsubst firemacs-node-start-pos (node)
  (overlay-start node))

(defsubst firemacs-node-end-pos (node)
  (overlay-end node))

(defsubst firemacs-node-role (node)
  (firemacs-node-get-property node 'fm-role))

;;}}}
;;{{{Finding nodes

(defmacro firemacs-buffer-nodes-do (node &rest body)
  `(loop for ,node being the hash-values of firemacs-buffer-node-table do
		 ,@body))

(defun firemacs-node-next-sibling (node)
  (let ((parent (firemacs-parent-node node)))
	(when parent
	  (cadr (memq node (firemacs-child-nodes parent))))))

(defun firemacs-node-previous-sibling (node)
  (let ((parent (firemacs-parent-node node)))
	(when parent
	  (cadr (memq node (reverse (firemacs-child-nodes parent)))))))

(defun firemacs-node-lineage (node)
  (let ((lineage  nil))
	(while node
	  (setq lineage (cons node lineage)
			node (firemacs-parent-node node)))
	lineage))

(defun firemacs-find-role-in-lineage (start-node roles)
  "Return node closest in lineage to  START-NODE whose role is in ROLES."
  (let ((lineage (nreverse (firemacs-node-lineage start-node))))
	(block result
	(loop for node in lineage do
		  (let ((role (firemacs-node-role node)))
			(when (and role (memq role roles))
			  (return-from result  node))))
	nil)))

(defun firemacs-next-node (start-pos roles &optional pred)
  "Return the next node after START-POS whose role is in ROLES."
  (let ((candidates nil))
	;; Filter out all candidates, i.e. nodes have a role in ROLES and
	;; a start position after START-POS
	(firemacs-buffer-nodes-do node
							  (let ((role (firemacs-node-role node)))
								(when (and role
										   (memq (firemacs-node-role node) roles)
										   (> (firemacs-node-start-pos node) start-pos)
										   (or (null pred) (funcall pred node)))
								  (push node candidates))))
	(when candidates
	  ;; Find the node with minimal buffor position
	  (reduce (lambda (n1 n2)
				(if (< (firemacs-node-start-pos n1) (firemacs-node-start-pos n2))
					n1
				  n2))
			  candidates))))


(defun firemacs-previous-node (start-pos roles &optional pred)
  "Return the next node before START-POS whose role is in ROLES."
  (let ((candidates nil))
	;; Filter out all candidates, i.e. nodes have a role in ROLES and
	;; a start position after START-POS
	(firemacs-buffer-nodes-do node
							  (let ((role (firemacs-node-role node)))
								(when (and role
										   (memq (firemacs-node-role node) roles)
										   (< (firemacs-node-start-pos node) start-pos)
										   (or (null pred) (funcall pred node)))
				   (push node candidates))))
	(when candidates
	  ;; Find the node with minimal buffor position
	  (reduce (lambda (n1 n2)
				(if (> (firemacs-node-start-pos n1) (firemacs-node-start-pos n2))
					n1
				  n2))
			  candidates))))

;;}}}
;;{{{Buffer mutation



(defun firemacs-buffer-clear ()
  "Clear firemacs buffer completely."
  (when (hash-table-p firemacs-buffer-node-table)
	(loop for o being the hash-values of firemacs-buffer-node-table do
	;; 			   (firemacs-node-clear o)
		  (delete-overlay o))
	(clrhash firemacs-buffer-node-table))
  (erase-buffer)
  ;; Mop up the remaining overlays (this should not be necessary if
  ;; there were a one to one correspondence between DOM nodes and
  ;; accessible nodes)
;  (loop for o being  the overlays do
										;(firemacs-node-clear o)
;		(delete-overlay o))
)
  

(defun firemacs-remove-node-ref (ref)
  "Remove Remove node REF and all its descendants from the buffer."
  (let ((node (firemacs-node-for-ref ref)))
	(when node
	  (firemacs-remove-node node))))

(defun firemacs-remove-node (node)
  "Remove NODE and all of its child nodes from the buffer.

Does not delete the text in the buffer. Tries to be thorough to allow for quick GC."
  (dolist (child (firemacs-child-nodes node))
	(firemacs-remove-node child))
  (remhash (firemacs-ref-for-node node) firemacs-buffer-node-table)
  (firemacs-node-clear node)
  (delete-overlay node))

(defsubst firemacs-node-clear (node)
  (loop for prop in (overlay-properties node) by 'cddr do
		(overlay-put node prop nil)))

(defsubst firemacs-node-fontify (node role)
  (let ((face (cdr-safe (assq role firemacs-role-font-alist))))
	(when face
	  (firemacs-node-set-property node 'face face))))

(defun firemacs-node-init-fields (node node-data)
  "Initialize the fields of NODE from NODE-DATA.

NODE-DATA is received from Firefox."
  (mozremote-dictionary-with  node-data (label state value)
							  (when label
								(firemacs-node-set-property node 'fm-label label))
							  (when state
								(firemacs-node-set-property node 'fm-state state))
							  (when value
								(firemacs-node-set-property node 'fm-value value))))
	  
(defun firemacs-render-children (node-data level)
  "Render child nodes of node represented by NODE-DATA."
  (let ((children (mozremote-dictionary-get 'cn node-data))
		(result nil))
	(when children
	  (mozremote-array-do child children
						  (push (firemacs-render-node child (1+ level)) result))
	  (nreverse result))))
  
(defun firemacs-render-node (node-data level)
  (mozremote-dictionary-with node-data
							 (epilog prolog ref role (more-props props))
							 (let (		 (start (point))
										 (role-sym (and role (intern role)))
										 (children nil))
							   (when prolog
								 (insert prolog)
								 (firemacs-insert-hard-newline))
							   (setq children (firemacs-render-children node-data (+ level 1)))
							   (when epilog
								 (insert epilog)
								 (firemacs-insert-hard-newline))
							   (let ((node  
									  (make-overlay start (point) (current-buffer) nil nil)))
								 (overlay-put node 'fm-ref ref)
								 (when role-sym
								   (overlay-put node 'fm-role role-sym)
								   (firemacs-node-fontify node role-sym)
								   (firemacs-node-init-fields node node-data))
								 (when more-props
								   (loop for (prop . value) in more-props do
										 (overlay-put node prop value)))
										;	  (when (gethash ref firemacs-buffer-node-table)
										;	(message "Duplicate node at %s" (buffer-substring start (point))))
								 (puthash ref node firemacs-buffer-node-table)
								 (overlay-put node 'priority level)
								 (when children
								   (dolist (child children)
									 (overlay-put child 'fm-parent node))
								   (overlay-put node 'fm-children  children))
								 node))))

;;}}}

;;{{{  emacs local variables

;;; local variables:
;;; folded-file: t
;;; byte-compile-dynamic: t
;;; end:

;;}}}

;;; firemacs-buffer.el ends here
